home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1998 November / Freeware November 1998.img / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / nnkiboze.el.z / nnkiboze.el
Lisp/Scheme  |  1998-10-27  |  14KB  |  389 lines
  1. ;;; nnkiboze.el --- select virtual news access for Gnus
  2. ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;; Keywords: news
  6.  
  7. ;; This file is part of GNU Emacs.
  8.  
  9. ;; GNU Emacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; GNU Emacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;; The other access methods (nntp, nnspool, etc) are general news
  27. ;; access methods. This module relies on Gnus and can not be used
  28. ;; separately.
  29.  
  30. ;;; Code:
  31.  
  32. (require 'nntp)
  33. (require 'nnheader)
  34. (require 'gnus)
  35. (require 'gnus-score)
  36. (require 'nnoo)
  37. (eval-when-compile (require 'cl))
  38.  
  39. (nnoo-declare nnkiboze)
  40. (defvoo nnkiboze-directory gnus-directory
  41.   "nnkiboze will put its files in this directory.")
  42.  
  43. (defvoo nnkiboze-level 9
  44.   "*The maximum level to be searched for articles.")
  45.  
  46. (defvoo nnkiboze-remove-read-articles t
  47.   "*If non-nil, nnkiboze will remove read articles from the kiboze group.")
  48.  
  49.  
  50.  
  51. (defconst nnkiboze-version "nnkiboze 1.0"
  52.   "Version numbers of this version of nnkiboze.")
  53.  
  54. (defvoo nnkiboze-current-group nil)
  55. (defvoo nnkiboze-current-score-group "")
  56. (defvoo nnkiboze-status-string "")
  57.  
  58.  
  59.  
  60. ;;; Interface functions.
  61.  
  62. (nnoo-define-basics nnkiboze)
  63.  
  64. (deffoo nnkiboze-retrieve-headers (articles &optional group server fetch-old)
  65.   (nnkiboze-possibly-change-newsgroups group)
  66.   (if gnus-nov-is-evil
  67.       nil
  68.     (if (stringp (car articles))
  69.     'headers
  70.       (let ((first (car articles))
  71.         (last (progn (while (cdr articles) (setq articles (cdr articles)))
  72.              (car articles)))
  73.         (nov (nnkiboze-nov-file-name)))
  74.     (if (file-exists-p nov)
  75.         (save-excursion
  76.           (set-buffer nntp-server-buffer)
  77.           (erase-buffer)
  78.           (insert-file-contents nov)
  79.           (goto-char (point-min))
  80.           (while (and (not (eobp)) (< first (read (current-buffer))))
  81.         (forward-line 1))
  82.           (beginning-of-line)
  83.           (if (not (eobp)) (delete-region 1 (point)))
  84.           (while (and (not (eobp)) (>= last (read (current-buffer))))
  85.         (forward-line 1))
  86.           (beginning-of-line)
  87.           (if (not (eobp)) (delete-region (point) (point-max)))
  88.           'nov))))))
  89.  
  90. (deffoo nnkiboze-open-server (newsgroups &optional something)
  91.   (gnus-make-directory nnkiboze-directory)
  92.   (nnheader-init-server-buffer))
  93.  
  94. (deffoo nnkiboze-server-opened (&optional server)
  95.   (and nntp-server-buffer
  96.        (get-buffer nntp-server-buffer)))
  97.  
  98. (deffoo nnkiboze-request-article (article &optional newsgroup server buffer)
  99.   (nnkiboze-possibly-change-newsgroups newsgroup)
  100.   (if (not (numberp article))
  101.       ;; This is a real kludge. It might not work at times, but it
  102.       ;; does no harm I think. The only alternative is to offer no
  103.       ;; article fetching by message-id at all.
  104.       (nntp-request-article article newsgroup gnus-nntp-server buffer)
  105.     (let* ((header (gnus-summary-article-header article))
  106.        (xref (mail-header-xref header))
  107.        igroup iarticle)
  108.       (or xref (error "nnkiboze: No xref"))
  109.       (or (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref)
  110.       (error "nnkiboze: Malformed xref"))
  111.       (setq igroup (substring xref (match-beginning 1) (match-end 1)))
  112.       (setq iarticle (string-to-int 
  113.               (substring xref (match-beginning 2) (match-end 2))))
  114.       (and (gnus-request-group igroup t)
  115.        (gnus-request-article iarticle igroup buffer)))))
  116.  
  117. (deffoo nnkiboze-request-group (group &optional server dont-check)
  118.   "Make GROUP the current newsgroup."
  119.   (nnkiboze-possibly-change-newsgroups group)
  120.   (if dont-check
  121.       ()
  122.     (let ((nov-file (nnkiboze-nov-file-name))
  123.       beg end total)
  124.       (save-excursion
  125.     (set-buffer nntp-server-buffer)
  126.     (erase-buffer)
  127.     (if (not (file-exists-p nov-file))
  128.         (insert (format "211 0 0 0 %s\n" group))
  129.       (insert-file-contents nov-file)
  130.       (if (zerop (buffer-size))
  131.           (insert (format "211 0 0 0 %s\n" group))
  132.         (goto-char (point-min))
  133.         (and (looking-at "[0-9]+") (setq beg (read (current-buffer))))
  134.         (goto-char (point-max))
  135.         (and (re-search-backward "^[0-9]" nil t)
  136.          (setq end (read (current-buffer))))
  137.         (setq total (count-lines (point-min) (point-max)))
  138.         (erase-buffer)
  139.         (insert (format "211 %d %d %d %s\n" total beg end group)))))))
  140.   t)
  141.  
  142. (deffoo nnkiboze-close-group (group &optional server)
  143.   (nnkiboze-possibly-change-newsgroups group)
  144.   ;; Remove NOV lines of articles that are marked as read.
  145.   (when (and (file-exists-p (nnkiboze-nov-file-name))
  146.          nnkiboze-remove-read-articles
  147.          (eq major-mode 'gnus-summary-mode))
  148.     (save-excursion
  149.       (let ((unreads gnus-newsgroup-unreads)
  150.         (unselected gnus-newsgroup-unselected)
  151.             (version-control 'never))
  152.     (set-buffer (get-buffer-create "*nnkiboze work*"))
  153.     (buffer-disable-undo (current-buffer))
  154.     (erase-buffer)
  155.     (let ((cur (current-buffer))
  156.           article)
  157.       (insert-file-contents (nnkiboze-nov-file-name))
  158.       (goto-char (point-min))
  159.       (while (looking-at "[0-9]+")
  160.         (if (or (memq (setq article (read cur)) unreads)
  161.             (memq article unselected))
  162.         (forward-line 1)
  163.           (delete-region (progn (beginning-of-line) (point))
  164.                  (progn (forward-line 1) (point)))))
  165.       (write-file (nnkiboze-nov-file-name))
  166.       (kill-buffer (current-buffer)))))
  167.     (setq nnkiboze-current-group nil)))
  168.  
  169. (deffoo nnkiboze-request-list (&optional server) 
  170.   (nnheader-report 'nnkiboze "LIST is not implemented."))
  171.  
  172. (deffoo nnkiboze-request-newgroups (date &optional server)
  173.   "List new groups."
  174.   (nnheader-report 'nnkiboze "NEWGROUPS is not supported."))
  175.  
  176. (deffoo nnkiboze-request-list-newsgroups (&optional server)
  177.   (nnheader-report 'nnkiboze "LIST NEWSGROUPS is not implemented."))
  178.  
  179. (deffoo nnkiboze-request-delete-group (group &optional force server)
  180.   (nnkiboze-possibly-change-newsgroups group)
  181.   (when force
  182.      (let ((files (list (nnkiboze-nov-file-name)
  183.             (concat nnkiboze-directory group ".newsrc")
  184.             (nnkiboze-score-file group))))
  185.        (while files
  186.      (and (file-exists-p (car files))
  187.           (file-writable-p (car files))
  188.           (delete-file (car files)))
  189.      (setq files (cdr files)))))
  190.   (setq nnkiboze-current-group nil))
  191.  
  192.  
  193. ;;; Internal functions.
  194.  
  195. (defun nnkiboze-possibly-change-newsgroups (group)
  196.   (setq nnkiboze-current-group group))
  197.  
  198. (defun nnkiboze-prefixed-name (group)
  199.   (gnus-group-prefixed-name group '(nnkiboze "")))
  200.  
  201. ;;;###autoload
  202. (defun nnkiboze-generate-groups ()
  203.   "Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups
  204. Finds out what articles are to be part of the nnkiboze groups."
  205.   (interactive)
  206.   (let ((nnmail-spool-file nil)
  207.     (gnus-use-dribble-file nil)
  208.     (gnus-read-active-file t)
  209.     (gnus-expert-user t))
  210.     (gnus))
  211.   (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist))
  212.      (newsrc gnus-newsrc-alist)
  213.      gnus-newsrc-hashtb)
  214.     (gnus-make-hashtable-from-newsrc-alist)
  215.     ;; We have copied all the newsrc alist info over to local copies
  216.     ;; so that we can mess all we want with these lists.
  217.     (while newsrc
  218.       (if (string-match "nnkiboze" (caar newsrc))
  219.       ;; For each kiboze group, we call this function to generate
  220.       ;; it.  
  221.       (nnkiboze-generate-group (caar newsrc)))
  222.       (setq newsrc (cdr newsrc)))))
  223.  
  224. (defun nnkiboze-score-file (group)
  225.   (list (expand-file-name
  226.      (concat (file-name-as-directory gnus-kill-files-directory)
  227.          (nnheader-translate-file-chars
  228.           (concat nnkiboze-current-score-group 
  229.               "." gnus-score-file-suffix))))))
  230.  
  231. (defun nnkiboze-generate-group (group) 
  232.   (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
  233.      (newsrc-file (concat nnkiboze-directory group ".newsrc"))
  234.      (nov-file (concat nnkiboze-directory group ".nov"))
  235.      (regexp (nth 1 (nth 4 info)))
  236.      (gnus-expert-user t)
  237.      (gnus-large-newsgroup nil)
  238.      (version-control 'never)
  239.      (gnus-score-find-score-files-function 'nnkiboze-score-file)
  240.       gnus-select-group-hook gnus-summary-prepare-hook 
  241.      gnus-thread-sort-functions gnus-show-threads 
  242.      gnus-visual
  243.      method nnkiboze-newsrc nov-buffer gname newsrc active
  244.      ginfo lowest glevel)
  245.     (setq nnkiboze-current-score-group group)
  246.     (or info (error "No such group: %s" group))
  247.     ;; Load the kiboze newsrc file for this group.
  248.     (and (file-exists-p newsrc-file) (load newsrc-file))
  249.     ;; We also load the nov file for this group.
  250.     (save-excursion
  251.       (set-buffer (setq nov-buffer (find-file-noselect nov-file)))
  252.       (buffer-disable-undo (current-buffer)))
  253.     ;; Go through the active hashtb and add new all groups that match the 
  254.     ;; kiboze regexp.
  255.     (mapatoms
  256.      (lambda (group)
  257.        (and (string-match regexp (setq gname (symbol-name group))) ; Match
  258.         (not (assoc gname nnkiboze-newsrc)) ; It isn't registered
  259.         (numberp (car (symbol-value group))) ; It is active
  260.         (or (> nnkiboze-level 7)
  261.         (and (setq glevel (nth 1 (nth 2 (gnus-gethash
  262.                          gname gnus-newsrc-hashtb))))
  263.              (>= nnkiboze-level glevel)))
  264.         (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes
  265.         (setq nnkiboze-newsrc 
  266.           (cons (cons gname (1- (car (symbol-value group))))
  267.             nnkiboze-newsrc))))
  268.      gnus-active-hashtb)
  269.     ;; `newsrc' is set to the list of groups that possibly are
  270.     ;; component groups to this kiboze group.  This list has elements
  271.     ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest
  272.     ;; number that has been kibozed in GROUP in this kiboze group.
  273.     (setq newsrc nnkiboze-newsrc)
  274.     (while newsrc
  275.       (if (not (setq active (gnus-gethash 
  276.                  (caar newsrc) gnus-active-hashtb)))
  277.       ;; This group isn't active after all, so we remove it from
  278.       ;; the list of component groups.
  279.       (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc))
  280.     (setq lowest (cdar newsrc))
  281.     ;; Ok, we have a valid component group, so we jump to it. 
  282.     (switch-to-buffer gnus-group-buffer)
  283.     (gnus-group-jump-to-group (caar newsrc))
  284.     ;; We set all list of article marks to nil.  Since we operate
  285.     ;; on copies of the real lists, we can destroy anything we
  286.     ;; want here.
  287.     (and (setq ginfo (nth 2 (gnus-gethash (gnus-group-group-name)
  288.                           gnus-newsrc-hashtb)))
  289.          (nth 3 ginfo)
  290.          (setcar (nthcdr 3 ginfo) nil))
  291.     ;; We set the list of read articles to be what we expect for
  292.     ;; this kiboze group -- either nil or `(1 . LOWEST)'. 
  293.     (and ginfo (setcar (nthcdr 2 ginfo)
  294.                (and (not (= lowest 1)) (cons 1 lowest))))
  295.     (if (not (and (or (not ginfo)
  296.               (> (length (gnus-list-of-unread-articles 
  297.                       (car ginfo))) 0))
  298.               (progn
  299.             (gnus-group-select-group nil)
  300.             (eq major-mode 'gnus-summary-mode))))
  301.         () ; No unread articles, or we couldn't enter this group.
  302.       ;; We are now in the group where we want to be.
  303.       (setq method (gnus-find-method-for-group gnus-newsgroup-name))
  304.       (and (eq method gnus-select-method) (setq method nil))
  305.       ;; We go through the list of scored articles.
  306.       (while gnus-newsgroup-scored
  307.         (if (> (caar gnus-newsgroup-scored) lowest)
  308.         ;; If it has a good score, then we enter this article
  309.         ;; into the kiboze group.
  310.         (nnkiboze-enter-nov 
  311.          nov-buffer
  312.          (gnus-summary-article-header 
  313.           (caar gnus-newsgroup-scored))
  314.          (if method
  315.              (gnus-group-prefixed-name gnus-newsgroup-name method)
  316.            gnus-newsgroup-name)))
  317.         (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored)))
  318.       ;; That's it.  We exit this group.
  319.       (gnus-summary-exit-no-update)))
  320.       (setcdr (car newsrc) (car active))
  321.       (setq newsrc (cdr newsrc)))
  322.     ;; We save the nov file.
  323.     (set-buffer nov-buffer)
  324.     (save-buffer)
  325.     (kill-buffer (current-buffer))
  326.     ;; We save the kiboze newsrc for this group.
  327.     (set-buffer (get-buffer-create "*nnkiboze work*"))
  328.     (buffer-disable-undo (current-buffer))
  329.     (erase-buffer)
  330.     (insert "(setq nnkiboze-newsrc '" (prin1-to-string nnkiboze-newsrc)
  331.         ")\n")
  332.     (write-file newsrc-file)
  333.     (kill-buffer (current-buffer))
  334.     (switch-to-buffer gnus-group-buffer)
  335.     (gnus-group-list-groups 5 nil)))
  336.     
  337. (defun nnkiboze-enter-nov (buffer header group)
  338.   (save-excursion
  339.     (set-buffer buffer)
  340.     (goto-char (point-max))
  341.     (let ((xref (mail-header-xref header))
  342.       (prefix (gnus-group-real-prefix group))
  343.       (first t)
  344.       article)
  345.       (if (zerop (forward-line -1))
  346.       (progn
  347.         (setq article (1+ (read (current-buffer))))
  348.         (forward-line 1))
  349.     (setq article 1))
  350.       (insert (int-to-string article) "\t"
  351.           (or (mail-header-subject header) "") "\t"
  352.           (or (mail-header-from header) "") "\t"
  353.           (or (mail-header-date header) "") "\t"
  354.           (or (mail-header-id header) "") "\t"
  355.           (or (mail-header-references header) "") "\t"
  356.           (int-to-string (or (mail-header-chars header) 0)) "\t"
  357.           (int-to-string (or (mail-header-lines header) 0)) "\t")
  358.       (if (or (not xref) (equal "" xref))
  359.       (insert "Xref: " (system-name) " " group ":" 
  360.           (int-to-string (mail-header-number header))
  361.           "\t\n")
  362.     (insert (mail-header-xref header) "\t\n")
  363.     (search-backward "\t" nil t)
  364.     (search-backward "\t" nil t)
  365.     (while (re-search-forward 
  366.         "[^ ]+:[0-9]+"
  367.         (save-excursion (end-of-line) (point)) t)
  368.       (if first
  369.           ;; The first xref has to be the group this article
  370.           ;; really came for - this is the article nnkiboze
  371.           ;; will request when it is asked for the article.
  372.           (save-excursion
  373.         (goto-char (match-beginning 0))
  374.         (insert prefix group ":" 
  375.             (int-to-string (mail-header-number header)) " ")
  376.         (setq first nil)))
  377.       (save-excursion
  378.         (goto-char (match-beginning 0))
  379.         (insert prefix)))))))
  380.  
  381. (defun nnkiboze-nov-file-name ()
  382.   (concat (file-name-as-directory nnkiboze-directory)
  383.       (nnheader-translate-file-chars
  384.        (concat (nnkiboze-prefixed-name nnkiboze-current-group) ".nov"))))
  385.  
  386. (provide 'nnkiboze)
  387.  
  388. ;;; nnkiboze.el ends here
  389.